;;;                I N  T H E   N A M E   O F   G O D
(defun persia ()
  (setvar "cmdecho" 0)
  (if (= (tblsearch "layer" "text" ) nil)
      (command "layer" "m" "text" "")
      (setvar "clayer" "text" )
  )
  (if (= (tblsearch "style" "sade" ) nil)
         (command "style" "sade" "sade" "" "" "" "y" "" )
  )
  (setq bm (getvar "BLIPMODE" ))
  (princ (strcat "\nFarsi Editor ,Version  2.0 "
                 ", (c) 1994 by R. Negarandeh ."))
  (if (= far nil)(load "farsi"))
  (cond
     ((= (getvar "textstyle") "SADE")    (setq th 3.70))
     ((= (getvar "textstyle") "CHAPI")   (setq th 3.70))
     ((= (getvar "textstyle") "FARSIN")  (setq th 2.61))
  )
  (setvar "BLIPMODE" 0 )
  (command "POINT" p1)
  (setvar "BLIPMODE" bm)
  (setq pnt (ssadd))
  (ssadd (setq last (entlast)) pnt)
  (command "text" p1 th "" "")
 (if (= x1 x2)
  (princ "\nUse command FIT before FE2 !")
  (progn
   (setq x1t (rtos x1 2 1) x2t (rtos x2 2 1))
   (princ(strcat "\nText(s) will be fitted between x=" x1t " and x=" x2t " :"))
   (farsil)
   (setvar "cmdecho" 0)
       (if (= (getvar "useri2") 1 )
         (progn
           (setq ssfit (ssadd))
             (while (/= (setq last (entnext last)) nil)
                (if (/= (substr (setq str (cdr (assoc 1 (entget last))))
                               (strlen str) 1 ) ".")
                    (ssadd last ssfit)
                )
             )
             (fittext ssfit)
         )
       )
  )
 )
  (setq p1 (cons x1 (cddr (assoc 10 (entget (entlast))))))
  (setvar "userr1" (car p1) )
  (setvar "userr2" (cadr p1))
  (setvar "userr3"  x1 )
  (setvar "userr4"  x2 )
  (command "erase" pnt "")
  (setvar "cmdecho" 1)
 (princ "\n Good luck !")
 (prin1)
)
; **********************************************************************
(defun fittext (sset)
  (setq sslen (sslength sset))
  (if (= x1 nil)
       (setq x1 180 x2 20)
  )
    (command "undo" "group")
  (while (> sslen 0)
    (setq ent (entget(ssname sset (setq sslen (1- sslen))))
          ent (subst (cons 72 5) (assoc 72 ent) ent)
          opt (trans (list (cadr (assoc 11 ent))
                           (caddr (assoc 11 ent))
                           (cadddr (assoc 11 ent)))
                     (cdr(assoc -1 ent)) ; from ECS
                     1)               ; to current UCS
    )
    (if (getvar "DIMCLRD")
      (setq ent (subst (cons 73 0) (assoc 73 ent) ent))
    )
        (redraw (cdr(assoc -1 ent)) 3)
        (setq p (cddr (assoc 10 ent)))
        (initget 1)
        (setq loc (cons x1 p ))
        (setq loc1 (cons x2 p ))
        (redraw (cdr(assoc -1 ent)) 1)
        (setq ent (subst (cons 10 loc) (assoc 10 ent) ent))
        (setq ent (subst (cons 11 loc1) (assoc 11 ent) ent))
    (entmod ent)
  )
  (command "undo" "end")
)
; *************************************************************************
(defun C:FIT ()
  (setvar "cmdecho" 0)
  (initget "ON OFf Defult Text Set")
  (setq ansr (getkword
    "\nON/OFF/Defult/Text(s)/<Set>:"))
  (cond
    ((= ansr "ON") (setvar "useri2" 1))
    ((= ansr "OFf")
        (progn
           (setvar "useri2" 0)
           (setq p1 (cons x1 (cddr (assoc 10 (entget (entlast))))))
           (setq p1 (cons x1 (cdr p1)))
           (setvar "userr1" (car p1) )
           (setvar "userr2" (cadr p1) )
           (setvar "userr3"  x1 )
           (setvar "userr4"  x2 )
        )
    )
    ((= ansr "Defult")
      (progn
         (setvar "useri2" 1)
         (setq x1 180 x2 20)
         (setq p1 (cons x1 (cddr (assoc 10 (entget (entlast))))))
         (setq p1 (cons x1 (cdr p1)))
         (setvar "userr1" (car p1) )
         (setvar "userr2" (cadr p1) )
         (setvar "userr3"  x1 )
         (setvar "userr4"  x2 )
      )
    )
    ((= ansr "Text")
      (progn
        (setq x1t (rtos x1 2 1) x2t (rtos x2 2 1))
        (princ (strcat "\nSelect text(s) to fit between x=" x1t " and x=" x2t
                       " :"))
        (verifylock )
        (setq names (list "TEXT")
              texts "TEXT" )
        (verify ssobj names texts)
        (fittext ssobj)
        (print ssl)
        (princ (strcat (strcase texts T) "(s) fitted ."))
      )
    )
    ((or (= ansr "Set" ) (= ansr nil))
      (progn
        (initget "Line Text Points" )
        (princ "\n Get alignment points:")
        (setq ansr1 (getkword "\nLine/Text/<Points>:"))
        (cond
          ((= ansr1 "Line")
              (progn
                (setq fl (entsel "\nSelect first line:"))
                 (if (= (cdr(assoc 0 (entget (car fl)))) "LINE")
                  (progn
                   (setq x1 (cadr (assoc 10 (entget (car fl)))))
                   (setq sl (entsel "\nSelect second line:"))
                     (if (= (cdr(assoc 0 (entget (car sl)))) "LINE")
                      (progn
                       (setq x2 (cadr (assoc 10 (entget (car sl)))))
                       (setvar "useri2" 1)
                       (setq p1 (cons x1 (cddr (assoc 10 (entget (entlast))))))
                       (setq p1 (cons x1 (cdr p1)))
                       (setvar "userr1" (car p1) )
                       (setvar "userr2" (cadr p1) )
                       (setvar "userr3"  x1 )
                       (setvar "userr4"  x2 )
                      )
                      (progn
                            (princ "\n Entity isn't a LINE")
                            (exit)
                      )
                     )
                  )
                  (progn
                     (princ "\n Entity isn't a LINE")
                  )
                 )
              )
          )
          ((= ansr1 "Text")
              (progn
                (setq fl (entsel "\nSelect base text:"))
                 (cond
                  ((and
                      (=  (cdr(assoc 0  (entget (car fl)))) "TEXT")
                      (/= (cdr(assoc 41 (entget (car fl)))) 1.0   )
                   )
                   (progn
                    (setq x1 (cadr (assoc 10 (entget (car fl)))))
                    (setq x2 (cadr (assoc 11 (entget (car fl)))))
                       (setvar "useri2" 1)
                       (setq p1 (cons x1 (cddr (assoc 10 (entget(entlast))))))
                       (setq p1 (cons x1 (cdr p1)))
                       (setvar "userr1" (car p1) )
                       (setvar "userr2" (cadr p1) )
                       (setvar "userr3"  x1 )
                       (setvar "userr4"  x2 )
                   )
                  )
                  (  (and
                        (= (cdr(assoc 0  (entget (car fl)))) "TEXT")
                        (= (cdr(assoc 41 (entget (car fl)))) 1.0   )
                     )
                      (progn
                            (princ "\nEntity isn't a fitted Text !")
                      )
                  )
                  (  (/= (cdr(assoc 0  (entget (car fl)))) "TEXT")
                      (progn
                            (princ "\n Entity isn't a TEXT")
                      )
                  )
                 )
              )
          )
          ((or (= ansr1 "Points") (= ansr1 nil))
              (progn
                (setq fp (getpoint "\n Select first point:  "))
                (setq sp (getpoint "\n Select second point:  "))
                 (if (and fp sp)
                      (progn
                       (setvar "useri2" 1)
                       (setq x1 (car fp) x2 (car sp))
                       (setq p1 (cons x1 (cddr (assoc 10 (entget (entlast))))))
                       (setq p1 (cons x1 (cdr p1)))
                       (setvar "userr1" (car p1) )
                       (setvar "userr2" (cadr p1) )
                       (setvar "userr3"  x1 )
                       (setvar "userr4"  x2 )
                      )
                      (progn
                         (princ "\n Nothing selected")
                         (exit)
                      )
                 )
              )
          )
        )
      )
    )
  )
 (setvar "cmdecho" 1)
 (princ "\n Good luck !")
 (prin1)
)
;;;
;;; Verify and sort out entities from the selection set.
;;;
(defun verify (sset entver texts)
  (setq ssl   (sslength sset)
        nsset (ssadd) )
  (if (> ssl 25)
    (princ "\nVerifying the selected entities -- please wait. ")
  )
  (while (> ssl 0)
             (setq temp (ssname sset (setq ssl (1- ssl))))
             (if (member (cdr(assoc 0 (entget temp))) entver)
                 (ssadd temp nsset)
             )
  )
  (setq ssl (sslength nsset)
        ssobj nsset
        unctr 0
  )
  (print ssl)
  (princ (strcat texts " entities found. "))
)
;;;
;;; Verify and sort out locked entities from the selection set.
;;;
(defun verifylock ()
         (setvar "blipmode"  0)
             (setq ssl 0)
             (setq sset (ssget))
         (if(= sset nil)
             (progn
                 (setq s 1)(setq sset (ssget "l"))(redraw (ssname sset 0) 3)
             )
         )
  (setq ssl   (sslength sset)
        nsset (ssadd))
  (while (> ssl 0)
    (setq temp (ssname sset (setq ssl (1- ssl))))
    (if (/=
            (cdr(assoc 70 (tblsearch "layer" (cdr (assoc 8 (entget temp))))))
             68
        )
      (ssadd temp nsset)
    )
  )
  (setq del (- (sslength sset) (sslength nsset)))
  (setq ssl (sslength nsset)
        ssobj nsset
        unctr 0
  )
  (print ssl)
  (princ " entities selected .")
  (print del)
  (princ " entities were on a locked leyer .")
)
;***********************************
(defun first ()
            (setvar "blipmode" 0)
            (command "style" "sade" "sade" "" "" "" "y" "" )
            (command "layer" "n" "lines,columns,cadr,text,id" "c" "6" "cadr"
                                                           "c" "8" "columns"
                                                           "c" "9" "lines"
                                                           "c" "2" "id"  ""
            )
            (command "line" "0,0" "210,0" " 210,297" "0,297" "c" )
            (command "zoom" "w" "09.80,140.0000" "193.9600,273.2900")
            (setvar "clayer" "lines")
            (command "line" "180.0,260.664" "20.0,260.664" "" )
            (command "array" "l" "" "r" "37" "1" "-6.3359")
            (setvar "clayer" "columns")
            (command "line" "84.852,26.2358" "84.852,267.0" "" )
            (command "array" "l" "" "r" "1" "6" "15.8580")
            (setvar "cecolor" "9")
            (command "line" "54.8876,267.0" "54.8876,26.2358" "" )
            (setvar "cecolor" "3")
            (command "line" "34.2722,267.0" "34.2722,26.2358" "" )
            (setvar "cecolor" "bylayer")
            (setvar "clayer" "cadr")
            (command "pline" "180.0,26.2358" "w" "1.0" "1.0"
                             "20.00,26.2358"
                             "20.00,267.000" "w" "0.0" "0.0"
                             "180.0,267.000" "c"
            )
            (setvar "clayer" "id")
            (command "text" "183.1914,241.6564" "3.7" "" "5")
            (command "text" "183.1914,216.3128" "3.7" "" "01")
            (command "text" "184.0174,190.9692" "3.7" "" "51")
            (command "text" "184.0174,165.6256" "3.7" "" "02")
            (command "text" "184.8935,140.2820" "3.7" "" "52")
            (command "text" "184.0299,114.9384" "3.7" "" "03")
            (command "text" "186.1450,089.5948" "3.7" "" "53")
            (command "text" "184.0174,064.2512" "3.7" "" "04")
            (command "text" "185.1062,032.5717" "3.7" "" "54")
            (command "ucsicon" "off")
            (command "ortho" "on")
            (setq p1 (list 180 273.3359 0))
            (setq x1 180 x2 20)
            (setvar "blipmode" 1)
)
;***********************************
;      S T A R T   U P
;***********************************
  (setvar "cmdecho" 0)
  (setq dis  6.3359)
  (setq pu1 (getvar "userr1"))
  (setq pu2 (getvar "userr2"))
  (setq p1 (list pu1 pu2 0 ))
  (setq x1 (getvar "userr3") x2 (getvar "userr4"))
  (setq ui (getvar "useri1"))
    (if (= ui  0  )
     (progn
        (initget "Yes No")
        (setq ans (getkword (strcat "\nDo you want to prepared"
                             " the screen as A4 size sheet ? Yes/<No>:")))
        (if  (= ans "Yes") (first))
     )
    )
 (setvar "useri1" 1)
 (setvar "useri2" 1)
 (setvar "cmdecho" 1)
(setq fe2id 1)
(defun c:FE2 ()(persia))
(princ (strcat "\n    <Farsi Editor II> loaded.  Start command with FE2 ." ))
(princ)
